home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Interface Toolkit-2.01 / item-defs.Lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  21.5 KB  |  521 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;  item-defs.lisp
  3. ;;
  4. ;;
  5. ;;  ©1989-1991 Apple Computer, Inc
  6. ;;
  7. ;;  definitions of object functions for particular classes of dialog-items, to
  8. ;;  support editing, printing, and copying.
  9. ;;
  10.  
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12. ;; 
  13. ;; Change History
  14. ;;
  15. ;; 04/28/93 mwp Release
  16. ;; 11/02/92 bill Be more explicit about the parameters for the prototype
  17. ;;               sequence dialog item.
  18. ;; ------------- 2.0
  19. ;; 03/05/92  wkf Changed "Print Item Source" button and "Print Dialog Source…"
  20. ;;               menu item to make a Scratch Fred buffer.This is since one
  21. ;;               rarely saves these buffers and this makes throwing them away
  22. ;;               easier. One can always use "Save as" to keep them.
  23. ;; ------------- 2.0f3
  24. ;; 12/18/91 bill add package prefixes to commented out object-source-code
  25. ;;               method for array-dialog-item
  26. ;; ------------- 2.0b4
  27. ;; 07/26/91 bill editors for fred-dialog-item's now have check box for
  28. ;;               allow-tabs & draw-outline
  29. ;; 07/09/91 bill window-font -> view-font
  30. ;; 07/05/91 bill :srccopy -> :srcor
  31. ;; 04/24/91 bill ALMS's fix to (method object-source-code (dialog-item))
  32.  
  33. (in-package :interface-tools)
  34.  
  35. ;;;;;;;;;;;;;;;;;;;;
  36. ;;
  37. ;; new classes
  38.  
  39. (defclass dialog-item-editor (non-editable-dialog)
  40.   ((edited-item :accessor dialog-item-editor-item)))
  41.  
  42. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43. ;;
  44. ;;  code for editing dialog-items
  45. ;;
  46.  
  47. (defparameter *editor-items-start-pos* #@(180 20))
  48.  
  49. (defun edit-dialog-item (item &optional (wpos #@(4 40)))
  50.     (let ((my-ed (get-dialog-item-editor item)))
  51.       (if my-ed
  52.           (window-select my-ed)
  53.           (setf (get-dialog-item-editor item)
  54.                 (make-instance 'dialog-item-editor
  55.                                :item item
  56.                                :view-position wpos)))))
  57.  
  58. (defmethod initialize-instance ((editor dialog-item-editor) &rest initargs &key
  59.                                 (item (make-instance 'button-dialog-item)))
  60.   (declare (dynamic-extent initargs))
  61.   (setf (dialog-item-editor-item editor) item)
  62.   (apply #'call-next-method
  63.          editor
  64.          :view-size (dialog-item-editor-size item)
  65.          :window-type :document
  66.          :window-title (format nil "Editor for ~s" (dialog-item-text item))
  67.          initargs)
  68.   (add-editor-items item editor))
  69.  
  70. (defmethod window-close :before ((editor dialog-item-editor))
  71.   (setf (get-dialog-item-editor (dialog-item-editor-item editor)) nil))
  72.  
  73. (defmethod dialog-item-editor-size ((item dialog-item))
  74.   #@(344 253))
  75.  
  76. (defmethod add-editor-items ((dialog-item dialog-item) editor)
  77.   (let* ((enabled (dialog-item-enabled-p dialog-item))
  78.          (text (dialog-item-text dialog-item)))
  79.     (add-subviews
  80.      editor
  81.      (make-dialog-item 'static-text-dialog-item
  82.                        #@(4 4) #@(125 16) "Dialog-item-text:")
  83.      (make-dialog-item 'editable-text-dialog-item
  84.                        #@(7 24) #@(148 80) text
  85.                        #'(lambda (item)
  86.                            (let ((text (dialog-item-text item)))
  87.                              (set-dialog-item-text dialog-item text)
  88.                              (set-window-title
  89.                               editor (format nil "Editor for ~s" text))))
  90.                        :allow-returns t)
  91.      (make-dialog-item 'radio-button-dialog-item
  92.                        #@(5 115) #@(72 16) "Enabled"
  93.                        #'(lambda (item)
  94.                            (declare (ignore item))
  95.                            (dialog-item-enable dialog-item))
  96.                        :radio-button-pushed-p enabled)
  97.      (make-dialog-item 'radio-button-dialog-item
  98.                        #@(85 115) #@(72 16) "Disabled"
  99.                        #'(lambda (item)
  100.                            (declare (ignore item))
  101.                            (dialog-item-disable dialog-item))
  102.                        :radio-button-pushed-p (not enabled))
  103.      (make-dialog-item 'button-dialog-item
  104.                        #@(5 137) #@(125 16) "Set Item Action"
  105.                        #'(lambda (item)
  106.                            (declare (ignore item))
  107.                            (new-action-from-dialog dialog-item)))
  108.      (make-dialog-item 'button-dialog-item
  109.                        #@(5 158) #@(125 16) "Set Item Font"
  110.                        #'(lambda (item)
  111.                            (declare (ignore item))
  112.                            (set-view-font 
  113.                             dialog-item
  114.                             (choose-font-dialog (view-font dialog-item)))))
  115.      (make-dialog-item 'button-dialog-item
  116.                        #@(5 179) #@(125 16) "Set Item Name"
  117.                        #'(lambda (item)
  118.                            (declare (ignore item))
  119.                            (set-item-nick-name dialog-item)))
  120.      (make-dialog-item 'color-part-pop-up
  121.                        #@(4 201)  #@(119 21) "Set Color" nil
  122.                        :part-codes '(:frame :text :body :thumb)
  123.                        :colored-object dialog-item)
  124.      (make-dialog-item 'button-dialog-item
  125.                        #@(5 231) #@(125 16) "Print Item Source"
  126.                        #'(lambda (item)
  127.                            (declare (ignore item))
  128.                            (let* ((*print-length* nil)
  129.                                   (*print-level* nil)
  130.                                   (*print-array* t)
  131.                                   (win (make-instance 'fred-window
  132.                                          :scratch-p t)))
  133.                              (pprint (object-source-code dialog-item) win)
  134.                              (fred-update win)))))))
  135.  
  136. ;;;;;;;;;;;;;;;;;;;;
  137. ;;
  138. ;;  definitions for various dialog-items
  139. ;;
  140.  
  141. ;;;; *button* ;;;;;
  142.  
  143. (add-editable-dialog-item (make-instance 'button-dialog-item
  144.                                          :dialog-item-text "Button"))
  145.  
  146. (defmethod add-editor-items ((button button-dialog-item) editor)
  147.   (let* ((default (default-button-p button))
  148.          (position *editor-items-start-pos*))
  149.     (call-next-method)
  150.     (add-subviews 
  151.      editor
  152.      (make-dialog-item 'check-box-dialog-item
  153.                        position #@(116 16) "Default Button"
  154.                        #'(lambda (item)
  155.                            (let ((checked (check-box-checked-p item))
  156.                                  (dialog (view-window button))
  157.                                  (old-editor (get-dialog-item-editor button)))
  158.                              (setf (get-dialog-item-editor button) nil)
  159.                              (if checked
  160.                                (set-default-button dialog button)
  161.                                (set-default-button dialog nil))
  162.                              (setf (get-dialog-item-editor button) old-editor)))
  163.                        :check-box-checked-p default))))
  164.  
  165.  
  166. ;;;; *static-text* ;;;;;
  167.  
  168. (add-editable-dialog-item (make-instance 'static-text-dialog-item
  169.                                          :dialog-item-text "Static Text"))
  170.  
  171. ;;;; *editable-text* ;;;;;
  172.  
  173. (add-editable-dialog-item (make-instance 'editable-text-dialog-item
  174.                                          :dialog-item-text "Edit Text"))
  175.  
  176. (defmethod add-editor-items :after ((text-item fred-dialog-item) editor)
  177.   (let* ((position *editor-items-start-pos*)
  178.          (size #@(116 16))
  179.          (delta (make-point 0 (+ (point-v size) 5))))
  180.       (add-subviews
  181.        editor
  182.        (make-dialog-item 'check-box-dialog-item
  183.                          position size "Allow Returns"
  184.                          #'(lambda (item)
  185.                              (setf (allow-returns-p text-item) 
  186.                                    (check-box-checked-p item)))
  187.                          :check-box-checked-p (allow-returns-p text-item))
  188.        (make-dialog-item 'check-box-dialog-item
  189.                          (setq position (add-points position delta))
  190.                          size "Allow Tabs"
  191.                          #'(lambda (item)
  192.                              (setf (allow-tabs-p text-item) 
  193.                                    (check-box-checked-p item)))
  194.                          :check-box-checked-p (allow-tabs-p text-item))
  195.        (make-dialog-item 'check-box-dialog-item
  196.                          (setq position (add-points position delta))
  197.                          size "Draw outline"
  198.                          #'(lambda (item)
  199.                              (invalidate-view text-item t)
  200.                              (setf (slot-value text-item 'ccl::draw-outline) 
  201.                                    (check-box-checked-p item))
  202.                              (invalidate-view text-item))
  203.                          :check-box-checked-p
  204.                          (slot-value text-item 'ccl::draw-outline)))))
  205.  
  206.  
  207. ;;;; *check-box* ;;;;;
  208.  
  209. (add-editable-dialog-item (make-instance 'check-box-dialog-item
  210.                                          :dialog-item-text "Check Box"))
  211.  
  212. (defmethod add-editor-items :after ((box-item check-box-dialog-item) editor)
  213.   (let* ((checked (check-box-checked-p box-item))
  214.          (position *editor-items-start-pos*))
  215.     (add-subviews
  216.        editor
  217.        (make-dialog-item 'check-box-dialog-item
  218.                          position #@(155 16) "Check Box Checked"
  219.                          #'(lambda (item)
  220.                              (if (check-box-checked-p item)
  221.                                (check-box-check box-item)
  222.                                (check-box-uncheck box-item)))
  223.                          :check-box-checked-p checked))))
  224.  
  225.  
  226.  
  227. ;;;; *radio-button* ;;;;;
  228.  
  229. (add-editable-dialog-item (make-instance 'radio-button-dialog-item
  230.                                          :dialog-item-text "Radio Button"))
  231.  
  232. (defmethod add-editor-items :after ((radio radio-button-dialog-item) editor)
  233.   (let* ((pushed (radio-button-pushed-p radio))
  234.          (position *editor-items-start-pos*))
  235.       (add-subviews
  236.        editor
  237.        (make-dialog-item 'check-box-dialog-item
  238.                          position #@(160 16) "Radio Button Pushed"
  239.                          #'(lambda (item)
  240.                              (if (check-box-checked-p item)
  241.                                (radio-button-push radio)
  242.                                (radio-button-unpush radio)))
  243.                          :check-box-checked-p pushed)
  244.        (make-dialog-item 'button-dialog-item
  245.                          (add-points position #@(0 24)) #@(150 16) "Set Item Cluster"
  246.                          #'(lambda (item)
  247.                              (declare (ignore item))
  248.                              (setf (radio-button-cluster radio)
  249.                                    (read-from-string
  250.                                     (get-string-from-user
  251.                                      "Please enter a new cluster for the radio button."
  252.                                      :initial-string
  253.                                      (format nil "~s" (radio-button-cluster radio))))))))))
  254.  
  255. ;;;; *table* ;;;;;
  256.  
  257. (defmethod add-editor-items :after ((table table-dialog-item) editor)
  258.   (let ((h-scrollp (table-hscrollp table))
  259.         (v-scrollp (table-vscrollp table))
  260.         (position *editor-items-start-pos*))
  261.     (labels ((change-scroll (check-box which-bar)
  262.                (let* ((checked (check-box-checked-p check-box))
  263.                       (owning-dialog (view-window table))
  264.                       (old-editor (get-dialog-item-editor table)))
  265.                  (setf (get-dialog-item-editor table) nil)
  266.                  (set-view-container table nil)
  267.                  (ecase which-bar
  268.                         (:vertical
  269.                          (setf (table-vscrollp table) checked))
  270.                         (:horizontal
  271.                          (setf (table-hscrollp table) checked)))
  272.                  (set-view-container table owning-dialog)
  273.                  (setf (get-dialog-item-editor table) old-editor))))
  274.       (add-subviews
  275.        editor
  276.        (make-dialog-item 'button-dialog-item
  277.                          position #@(130 16) "Set Cell Size"
  278.                          #'(lambda (item)
  279.                              (declare (ignore item))
  280.                              (set-cell-size
  281.                               table
  282.                               (read-from-string
  283.                                (get-string-from-user
  284.                                 "Please enter a new Cell Size."
  285.                                 :initial-string
  286.                                 (format nil "~s" (ppoint (cell-size table))))))
  287.                              (invalidate-view table)))
  288.          (make-dialog-item 'check-box-dialog-item
  289.                            (add-points position #@(0 22)) #@(175 16) "Horizontal Scrollbar"
  290.                            #'(lambda (item)
  291.                                (change-scroll item :horizontal))
  292.                            :check-box-checked-p h-scrollp)
  293.          (make-dialog-item 'check-box-dialog-item
  294.                            (add-points position #@(0 44)) #@(175 16) "Vertical Scrollbar"
  295.                            #'(lambda (item)
  296.                                (change-scroll item :vertical))
  297.                            :check-box-checked-p v-scrollp)))))
  298.  
  299. (defun get-new-table-data (old-data data-name)
  300.   (let* ((*print-length* nil)
  301.          (*print-level* nil))
  302.     (read-from-string
  303.      (get-text-from-user
  304.       (format nil "Please enter a new ~a for the table." data-name)
  305.       (format nil "~s" old-data)))))
  306.  
  307. ;;sequence-dialog-item
  308.  
  309.  
  310. (add-editable-dialog-item (make-instance 'sequence-dialog-item
  311.                             :table-sequence '(1 2 3)
  312.                             :view-size #@(29 63)
  313.                             :table-hscrollp nil
  314.                             :table-vscrollp nil))
  315.  
  316. (defmethod add-editor-items :after ((sequence sequence-dialog-item) editor)
  317.   (let ((position (add-points *editor-items-start-pos* #@(0 66)))
  318.         (orient (slot-value sequence 'ccl::sequence-order)))
  319.     (add-subviews
  320.      editor
  321.      (make-dialog-item 'button-dialog-item
  322.                        position #@(130 16) "Set Table Sequence"
  323.                        #'(lambda (item)
  324.                            (declare (ignore item))
  325.                            (set-table-sequence
  326.                             sequence
  327.                             (get-new-table-data 
  328.                              (table-sequence sequence) "sequence"))))
  329.      (make-dialog-item 'button-dialog-item
  330.                        (add-points position #@(0 22)) #@(130 16) "Set Wrap Length"
  331.                        #'(lambda (item)
  332.                            (declare (ignore item))
  333.                            (setf (slot-value sequence 'ccl::sequence-wrap-length)
  334.                                  (read-from-string
  335.                                   (get-string-from-user
  336.                                    "Please enter a new length."
  337.                                    :initial-string
  338.                                    (format nil "~a"
  339.                                            (slot-value sequence 'ccl::sequence-wrap-length)))))
  340.                            (set-table-sequence
  341.                             sequence (table-sequence sequence))))
  342.      (make-dialog-item 'static-text-dialog-item
  343.                        (add-points position #@(0 44)) #@(130 16) "Orientation:")
  344.      (make-dialog-item 'radio-button-dialog-item
  345.                        (add-points position #@(30 60)) #@(100 16) "Vertical"
  346.                        #'(lambda (item)
  347.                            (declare (ignore item))
  348.                            (setf (slot-value sequence 'ccl::sequence-order) :vertical)
  349.                            (set-table-sequence
  350.                             sequence (table-sequence sequence)))
  351.                        :radio-button-pushed-p (eq orient :vertical))
  352.      (make-dialog-item 'radio-button-dialog-item
  353.                        (add-points position #@(30 76)) #@(100 16) "Horizontal"
  354.                        #'(lambda (item)
  355.                            (declare (ignore item))
  356.                            (setf (slot-value sequence 'ccl::sequence-order) :horizontal)
  357.                            (set-table-sequence
  358.                             sequence (table-sequence sequence)))
  359.                        :radio-button-pushed-p (eq orient :horizontal)))))
  360. #|
  361. ;;array-dialog-item
  362.  
  363. (add-editable-dialog-item (make-instance 'array-dialog-item))
  364.  
  365. (defmethod add-editor-items :after ((array array-dialog-item) editor)
  366.   (let ((position (add-points *editor-items-start-pos* #@(0 66))))
  367.     (add-subviews
  368.      editor
  369.      (make-dialog-item 'button-dialog-item
  370.                        position #@(130 16) "Set Table Array"
  371.                        #'(lambda (item)
  372.                            (declare (ignore item))
  373.                            (let* ((*print-array* t))
  374.                              (set-table-array
  375.                               array
  376.                               (get-new-table-data (table-array array)
  377.                                                   "array"))))))))
  378. |#
  379.  
  380. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  381. ;;
  382. ;;  definitions for printing the source code
  383. ;;
  384.  
  385. (defmethod pprint-source ((window window))
  386.   (let* ((*print-length* nil)
  387.          (*print-level* nil)
  388.          (*print-array* t)
  389.          (win (make-instance 'fred-window :scratch-p t)))
  390.     (pprint (object-source-code window) win)
  391.     (fred-update win)))
  392.  
  393. (defmethod object-source-code ((window window) &aux my-font)
  394.   `(make-instance ',(if (window-color-p window) 'color-dialog 'dialog)
  395.                   :window-type ,(window-type window)
  396.                   ,@(let ((title (window-title window)))
  397.                       (if (or (string-equal title "Untitled Dialog")
  398.                               (string-equal title "Untitled"))
  399.                         nil
  400.                         `(:window-title ,title)))
  401.                   :view-position ,(let ((pos (window-centered-p window)))
  402.                                       (if (fixnump pos)
  403.                                         (ppoint pos)
  404.                                         (list 'quote pos)))
  405.                   :view-size ,(ppoint (view-size window))
  406.                   ,@(if (rref (wptr window) windowRecord.goawayflag)
  407.                       nil
  408.                       '(:close-box-p nil))
  409.                   ,@(if (equal (setq my-font (view-font window))
  410.                                '("Chicago" 0 :srcor :plain))
  411.                       nil
  412.                       `(:view-font ',my-font))
  413.                   :view-subviews (list ,@(map 'list #'(lambda (item)
  414.                                                         (object-source-code item))
  415.                                               (view-subviews window)))))
  416.  
  417. (defmethod object-source-code ((item dialog-item) &aux my-font)
  418.   `(make-dialog-item  ',(class-name (class-of item))
  419.                       ,(ppoint (view-position item))
  420.                       ,(ppoint (view-size item))
  421.                       ,(dialog-item-text item)
  422.                       ,(let* ((f (dialog-item-action-function item))
  423.                               (code (and (functionp f) (uncompile-function f))))
  424.                          (cond ((symbolp f) `',f)
  425.                                (code `#',code)
  426.                                (t nil)))
  427.                       ,@(let ((nick-name (view-nick-name item)))
  428.                           (and nick-name
  429.                                `(:view-nick-name ',nick-name)))
  430.                       ,@(if (dialog-item-enabled-p item)
  431.                           ()
  432.                           '(:dialog-item-enabled-p nil))
  433.                       ,@(if (equal (setq my-font (view-font item))
  434.                                    (view-font (view-window item)))
  435.                           ()
  436.                           `(:view-font ',my-font))
  437.                       ,@(let ((color-list (part-color-list item)))
  438.                           (and color-list
  439.                                `(:part-color-list ',color-list)))))
  440.  
  441.  
  442. ;;;;;;;;;;;;;;;;;;;;
  443. ;;
  444. ;;  definitions for various dialog-items
  445. ;;
  446.  
  447. ;;;; *button* ;;;;;
  448.  
  449. (defmethod object-source-code ((item button-dialog-item))
  450.   (nconc (call-next-method)
  451.          `(:default-button ,(default-button-p item))))
  452.  
  453. ;;;; *static-text* ;;;;;
  454.  
  455. ;no additional defs needed
  456.  
  457.  
  458. ;;;; *editable-text* ;;;;;
  459.  
  460. (defmethod object-source-code ((item fred-dialog-item))
  461.   (nconc (call-next-method)
  462.          `(:allow-returns ,(allow-returns-p item))))
  463.  
  464.  
  465. ;;;; *check-box* ;;;;;
  466.  
  467. (defmethod object-source-code ((item check-box-dialog-item))
  468.   (nconc (call-next-method)
  469.          (if (check-box-checked-p item)
  470.              (list :check-box-checked-p t)
  471.              ())))
  472.  
  473.  
  474. ;;;; *radio-button* ;;;;;
  475.  
  476. (defmethod object-source-code ((item radio-button-dialog-item))
  477.   (nconc (call-next-method)
  478.          `(,@(if (radio-button-pushed-p item)
  479.                  '(:radio-button-pushed-p t)
  480.                  nil)
  481.            ,@(let ((cluster (radio-button-cluster item)))
  482.                (if (eql 0 (radio-button-cluster item))
  483.                  nil
  484.                  `(:radio-button-cluster ,cluster))))))
  485.  
  486.  
  487. ;;;; *table* ;;;;;
  488.  
  489. (defmethod object-source-code ((item table-dialog-item))
  490.   (nconc (call-next-method)
  491.          `(:cell-size ,(ppoint (cell-size item))
  492.            :selection-type ,(slot-value item 'ccl::selection-type)
  493.            :table-hscrollp ,(table-hscrollp item)
  494.            :table-vscrollp ,(table-vscrollp item))))
  495.  
  496.  
  497. ;;;; *sequence-table* ;;;;;
  498.  
  499. (defmethod object-source-code ((item sequence-dialog-item))
  500.   (let* ((wrap (slot-value item 'ccl::sequence-wrap-length))
  501.          (order (slot-value item 'ccl::sequence-order)))
  502.     (nconc (call-next-method)
  503.            `(:table-sequence ',(table-sequence item))
  504.            (if (eq wrap most-positive-fixnum)
  505.                nil
  506.                `(:sequence-wrap-length ,wrap))
  507.            (if (eq order :vertical)
  508.                nil
  509.                `(:sequence-order ,order)))))
  510.  
  511. #|
  512. ;;;; *array-table* ;;;;;
  513.  
  514. (defmethod object-source-code ((item ccl:array-dialog-item))
  515.   (nconc (call-next-method)
  516.          `(:table-array ',(ccl:table-array item)))) |#
  517.  
  518.  
  519. ;;all done
  520. (provide 'item-defs)
  521.